<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
 <head>
  <title>slahqr.f</title>
 <meta name="generator" content="emacs 21.3.1; htmlfontify 0.20">
<style type="text/css"><!-- 
body { background: rgb(255, 255, 255);  color: rgb(0, 0, 0);  font-style: normal;  font-weight: 500;  font-stretch: normal;  font-family: adobe-courier;  font-size: 11pt;  text-decoration: none; }
span.default   { background: rgb(255, 255, 255);  color: rgb(0, 0, 0);  font-style: normal;  font-weight: 500;  font-stretch: normal;  font-family: adobe-courier;  font-size: 11pt;  text-decoration: none; }
span.default a { background: rgb(255, 255, 255);  color: rgb(0, 0, 0);  font-style: normal;  font-weight: 500;  font-stretch: normal;  font-family: adobe-courier;  font-size: 11pt;  text-decoration: underline; }
span.string   { color: rgb(188, 143, 143);  background: rgb(255, 255, 255);  font-style: normal;  font-weight: 500;  font-stretch: normal;  font-family: adobe-courier;  font-size: 11pt;  text-decoration: none; }
span.string a { color: rgb(188, 143, 143);  background: rgb(255, 255, 255);  font-style: normal;  font-weight: 500;  font-stretch: normal;  font-family: adobe-courier;  font-size: 11pt;  text-decoration: underline; }
span.comment   { color: rgb(178, 34, 34);  background: rgb(255, 255, 255);  font-style: normal;  font-weight: 500;  font-stretch: normal;  font-family: adobe-courier;  font-size: 11pt;  text-decoration: none; }
span.comment a { color: rgb(178, 34, 34);  background: rgb(255, 255, 255);  font-style: normal;  font-weight: 500;  font-stretch: normal;  font-family: adobe-courier;  font-size: 11pt;  text-decoration: underline; }
 --></style>

 </head>
  <body>

<pre>
      SUBROUTINE <a name="SLAHQR.1"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a>( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
     $                   ILOZ, IHIZ, Z, LDZ, INFO )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">  -- LAPACK auxiliary routine (version 3.1) --
</span><span class="comment">*</span><span class="comment">     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
</span><span class="comment">*</span><span class="comment">     November 2006
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     .. Scalar Arguments ..
</span>      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
      LOGICAL            WANTT, WANTZ
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Array Arguments ..
</span>      REAL               H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Purpose
</span><span class="comment">*</span><span class="comment">     =======
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     <a name="SLAHQR.19"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a> is an auxiliary routine called by <a name="SHSEQR.19"></a><a href="shseqr.f.html#SHSEQR.1">SHSEQR</a> to update the
</span><span class="comment">*</span><span class="comment">     eigenvalues and Schur decomposition already computed by <a name="SHSEQR.20"></a><a href="shseqr.f.html#SHSEQR.1">SHSEQR</a>, by
</span><span class="comment">*</span><span class="comment">     dealing with the Hessenberg submatrix in rows and columns ILO to
</span><span class="comment">*</span><span class="comment">     IHI.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Arguments
</span><span class="comment">*</span><span class="comment">     =========
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     WANTT   (input) LOGICAL
</span><span class="comment">*</span><span class="comment">          = .TRUE. : the full Schur form T is required;
</span><span class="comment">*</span><span class="comment">          = .FALSE.: only eigenvalues are required.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     WANTZ   (input) LOGICAL
</span><span class="comment">*</span><span class="comment">          = .TRUE. : the matrix of Schur vectors Z is required;
</span><span class="comment">*</span><span class="comment">          = .FALSE.: Schur vectors are not required.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     N       (input) INTEGER
</span><span class="comment">*</span><span class="comment">          The order of the matrix H.  N &gt;= 0.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     ILO     (input) INTEGER
</span><span class="comment">*</span><span class="comment">     IHI     (input) INTEGER
</span><span class="comment">*</span><span class="comment">          It is assumed that H is already upper quasi-triangular in
</span><span class="comment">*</span><span class="comment">          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
</span><span class="comment">*</span><span class="comment">          ILO = 1). <a name="SLAHQR.42"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a> works primarily with the Hessenberg
</span><span class="comment">*</span><span class="comment">          submatrix in rows and columns ILO to IHI, but applies
</span><span class="comment">*</span><span class="comment">          transformations to all of H if WANTT is .TRUE..
</span><span class="comment">*</span><span class="comment">          1 &lt;= ILO &lt;= max(1,IHI); IHI &lt;= N.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     H       (input/output) REAL array, dimension (LDH,N)
</span><span class="comment">*</span><span class="comment">          On entry, the upper Hessenberg matrix H.
</span><span class="comment">*</span><span class="comment">          On exit, if INFO is zero and if WANTT is .TRUE., H is upper
</span><span class="comment">*</span><span class="comment">          quasi-triangular in rows and columns ILO:IHI, with any
</span><span class="comment">*</span><span class="comment">          2-by-2 diagonal blocks in standard form. If INFO is zero
</span><span class="comment">*</span><span class="comment">          and WANTT is .FALSE., the contents of H are unspecified on
</span><span class="comment">*</span><span class="comment">          exit.  The output state of H if INFO is nonzero is given
</span><span class="comment">*</span><span class="comment">          below under the description of INFO.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     LDH     (input) INTEGER
</span><span class="comment">*</span><span class="comment">          The leading dimension of the array H. LDH &gt;= max(1,N).
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     WR      (output) REAL array, dimension (N)
</span><span class="comment">*</span><span class="comment">     WI      (output) REAL array, dimension (N)
</span><span class="comment">*</span><span class="comment">          The real and imaginary parts, respectively, of the computed
</span><span class="comment">*</span><span class="comment">          eigenvalues ILO to IHI are stored in the corresponding
</span><span class="comment">*</span><span class="comment">          elements of WR and WI. If two eigenvalues are computed as a
</span><span class="comment">*</span><span class="comment">          complex conjugate pair, they are stored in consecutive
</span><span class="comment">*</span><span class="comment">          elements of WR and WI, say the i-th and (i+1)th, with
</span><span class="comment">*</span><span class="comment">          WI(i) &gt; 0 and WI(i+1) &lt; 0. If WANTT is .TRUE., the
</span><span class="comment">*</span><span class="comment">          eigenvalues are stored in the same order as on the diagonal
</span><span class="comment">*</span><span class="comment">          of the Schur form returned in H, with WR(i) = H(i,i), and, if
</span><span class="comment">*</span><span class="comment">          H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
</span><span class="comment">*</span><span class="comment">          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     ILOZ    (input) INTEGER
</span><span class="comment">*</span><span class="comment">     IHIZ    (input) INTEGER
</span><span class="comment">*</span><span class="comment">          Specify the rows of Z to which transformations must be
</span><span class="comment">*</span><span class="comment">          applied if WANTZ is .TRUE..
</span><span class="comment">*</span><span class="comment">          1 &lt;= ILOZ &lt;= ILO; IHI &lt;= IHIZ &lt;= N.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Z       (input/output) REAL array, dimension (LDZ,N)
</span><span class="comment">*</span><span class="comment">          If WANTZ is .TRUE., on entry Z must contain the current
</span><span class="comment">*</span><span class="comment">          matrix Z of transformations accumulated by <a name="SHSEQR.80"></a><a href="shseqr.f.html#SHSEQR.1">SHSEQR</a>, and on
</span><span class="comment">*</span><span class="comment">          exit Z has been updated; transformations are applied only to
</span><span class="comment">*</span><span class="comment">          the submatrix Z(ILOZ:IHIZ,ILO:IHI).
</span><span class="comment">*</span><span class="comment">          If WANTZ is .FALSE., Z is not referenced.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     LDZ     (input) INTEGER
</span><span class="comment">*</span><span class="comment">          The leading dimension of the array Z. LDZ &gt;= max(1,N).
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     INFO    (output) INTEGER
</span><span class="comment">*</span><span class="comment">           =   0: successful exit
</span><span class="comment">*</span><span class="comment">          .GT. 0: If INFO = i, <a name="SLAHQR.90"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a> failed to compute all the
</span><span class="comment">*</span><span class="comment">                  eigenvalues ILO to IHI in a total of 30 iterations
</span><span class="comment">*</span><span class="comment">                  per eigenvalue; elements i+1:ihi of WR and WI
</span><span class="comment">*</span><span class="comment">                  contain those eigenvalues which have been
</span><span class="comment">*</span><span class="comment">                  successfully computed.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                  If INFO .GT. 0 and WANTT is .FALSE., then on exit,
</span><span class="comment">*</span><span class="comment">                  the remaining unconverged eigenvalues are the
</span><span class="comment">*</span><span class="comment">                  eigenvalues of the upper Hessenberg matrix rows
</span><span class="comment">*</span><span class="comment">                  and columns ILO thorugh INFO of the final, output
</span><span class="comment">*</span><span class="comment">                  value of H.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                  If INFO .GT. 0 and WANTT is .TRUE., then on exit
</span><span class="comment">*</span><span class="comment">          (*)       (initial value of H)*U  = U*(final value of H)
</span><span class="comment">*</span><span class="comment">                  where U is an orthognal matrix.    The final
</span><span class="comment">*</span><span class="comment">                  value of H is upper Hessenberg and triangular in
</span><span class="comment">*</span><span class="comment">                  rows and columns INFO+1 through IHI.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit
</span><span class="comment">*</span><span class="comment">                      (final value of Z)  = (initial value of Z)*U
</span><span class="comment">*</span><span class="comment">                  where U is the orthogonal matrix in (*)
</span><span class="comment">*</span><span class="comment">                  (regardless of the value of WANTT.)
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Further Details
</span><span class="comment">*</span><span class="comment">     ===============
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     02-96 Based on modifications by
</span><span class="comment">*</span><span class="comment">     David Day, Sandia National Laboratory, USA
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     12-04 Further modifications by
</span><span class="comment">*</span><span class="comment">     Ralph Byers, University of Kansas, USA
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">       This is a modified version of <a name="SLAHQR.122"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a> from LAPACK version 3.0.
</span><span class="comment">*</span><span class="comment">       It is (1) more robust against overflow and underflow and
</span><span class="comment">*</span><span class="comment">       (2) adopts the more conservative Ahues &amp; Tisseur stopping
</span><span class="comment">*</span><span class="comment">       criterion (LAWN 122, 1997).
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     =========================================================
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     .. Parameters ..
</span>      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 30 )
      REAL               ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0, TWO = 2.0e0 )
      REAL               DAT1, DAT2
      PARAMETER          ( DAT1 = 3.0e0 / 4.0e0, DAT2 = -0.4375e0 )
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Local Scalars ..
</span>      REAL               AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
     $                   H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
     $                   SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
     $                   ULP, V2, V3
      INTEGER            I, I1, I2, ITS, J, K, L, M, NH, NR, NZ
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Local Arrays ..
</span>      REAL               V( 3 )
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. External Functions ..
</span>      REAL               <a name="SLAMCH.148"></a><a href="slamch.f.html#SLAMCH.1">SLAMCH</a>
      EXTERNAL           <a name="SLAMCH.149"></a><a href="slamch.f.html#SLAMCH.1">SLAMCH</a>
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. External Subroutines ..
</span>      EXTERNAL           SCOPY, <a name="SLABAD.152"></a><a href="slabad.f.html#SLABAD.1">SLABAD</a>, <a name="SLANV2.152"></a><a href="slanv2.f.html#SLANV2.1">SLANV2</a>, <a name="SLARFG.152"></a><a href="slarfg.f.html#SLARFG.1">SLARFG</a>, SROT
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Intrinsic Functions ..
</span>      INTRINSIC          ABS, MAX, MIN, REAL, SQRT
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Executable Statements ..
</span><span class="comment">*</span><span class="comment">
</span>      INFO = 0
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Quick return if possible
</span><span class="comment">*</span><span class="comment">
</span>      IF( N.EQ.0 )
     $   RETURN
      IF( ILO.EQ.IHI ) THEN
         WR( ILO ) = H( ILO, ILO )
         WI( ILO ) = ZERO
         RETURN
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     ==== clear out the trash ====
</span>      DO 10 J = ILO, IHI - 3
         H( J+2, J ) = ZERO
         H( J+3, J ) = ZERO
   10 CONTINUE
      IF( ILO.LE.IHI-2 )
     $   H( IHI, IHI-2 ) = ZERO
<span class="comment">*</span><span class="comment">
</span>      NH = IHI - ILO + 1
      NZ = IHIZ - ILOZ + 1
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Set machine-dependent constants for the stopping criterion.
</span><span class="comment">*</span><span class="comment">
</span>      SAFMIN = <a name="SLAMCH.184"></a><a href="slamch.f.html#SLAMCH.1">SLAMCH</a>( <span class="string">'SAFE MINIMUM'</span> )
      SAFMAX = ONE / SAFMIN
      CALL <a name="SLABAD.186"></a><a href="slabad.f.html#SLABAD.1">SLABAD</a>( SAFMIN, SAFMAX )
      ULP = <a name="SLAMCH.187"></a><a href="slamch.f.html#SLAMCH.1">SLAMCH</a>( <span class="string">'PRECISION'</span> )
      SMLNUM = SAFMIN*( REAL( NH ) / ULP )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     I1 and I2 are the indices of the first row and last column of H
</span><span class="comment">*</span><span class="comment">     to which transformations must be applied. If eigenvalues only are
</span><span class="comment">*</span><span class="comment">     being computed, I1 and I2 are set inside the main loop.
</span><span class="comment">*</span><span class="comment">
</span>      IF( WANTT ) THEN
         I1 = 1
         I2 = N
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     The main loop begins here. I is the loop index and decreases from
</span><span class="comment">*</span><span class="comment">     IHI to ILO in steps of 1 or 2. Each iteration of the loop works
</span><span class="comment">*</span><span class="comment">     with the active submatrix in rows and columns L to I.
</span><span class="comment">*</span><span class="comment">     Eigenvalues I+1 to IHI have already converged. Either L = ILO or
</span><span class="comment">*</span><span class="comment">     H(L,L-1) is negligible so that the matrix splits.
</span><span class="comment">*</span><span class="comment">
</span>      I = IHI
   20 CONTINUE
      L = ILO
      IF( I.LT.ILO )
     $   GO TO 160
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Perform QR iterations on rows and columns ILO to I until a
</span><span class="comment">*</span><span class="comment">     submatrix of order 1 or 2 splits off at the bottom because a
</span><span class="comment">*</span><span class="comment">     subdiagonal element has become negligible.
</span><span class="comment">*</span><span class="comment">
</span>      DO 140 ITS = 0, ITMAX
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Look for a single small subdiagonal element.
</span><span class="comment">*</span><span class="comment">
</span>         DO 30 K = I, L + 1, -1
            IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
     $         GO TO 40
            TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
            IF( TST.EQ.ZERO ) THEN
               IF( K-2.GE.ILO )
     $            TST = TST + ABS( H( K-1, K-2 ) )
               IF( K+1.LE.IHI )
     $            TST = TST + ABS( H( K+1, K ) )
            END IF
<span class="comment">*</span><span class="comment">           ==== The following is a conservative small subdiagonal
</span><span class="comment">*</span><span class="comment">           .    deflation  criterion due to Ahues &amp; Tisseur (LAWN 122,
</span><span class="comment">*</span><span class="comment">           .    1997). It has better mathematical foundation and
</span><span class="comment">*</span><span class="comment">           .    improves accuracy in some cases.  ====
</span>            IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
               AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
               BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
               AA = MAX( ABS( H( K, K ) ),
     $              ABS( H( K-1, K-1 )-H( K, K ) ) )
               BB = MIN( ABS( H( K, K ) ),
     $              ABS( H( K-1, K-1 )-H( K, K ) ) )
               S = AA + AB
               IF( BA*( AB / S ).LE.MAX( SMLNUM,
     $             ULP*( BB*( AA / S ) ) ) )GO TO 40
            END IF
   30    CONTINUE
   40    CONTINUE
         L = K
         IF( L.GT.ILO ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           H(L,L-1) is negligible
</span><span class="comment">*</span><span class="comment">
</span>            H( L, L-1 ) = ZERO
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Exit from loop if a submatrix of order 1 or 2 has split off.
</span><span class="comment">*</span><span class="comment">
</span>         IF( L.GE.I-1 )
     $      GO TO 150
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Now the active submatrix is in rows and columns L to I. If
</span><span class="comment">*</span><span class="comment">        eigenvalues only are being computed, only the active submatrix
</span><span class="comment">*</span><span class="comment">        need be transformed.
</span><span class="comment">*</span><span class="comment">
</span>         IF( .NOT.WANTT ) THEN
            I1 = L
            I2 = I
         END IF
<span class="comment">*</span><span class="comment">
</span>         IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Exceptional shift.
</span><span class="comment">*</span><span class="comment">
</span>            H11 = DAT1*S + H( I, I )
            H12 = DAT2*S
            H21 = S
            H22 = H11
         ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Prepare to use Francis' double shift
</span><span class="comment">*</span><span class="comment">           (i.e. 2nd degree generalized Rayleigh quotient)
</span><span class="comment">*</span><span class="comment">
</span>            H11 = H( I-1, I-1 )
            H21 = H( I, I-1 )
            H12 = H( I-1, I )
            H22 = H( I, I )
         END IF
         S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
         IF( S.EQ.ZERO ) THEN
            RT1R = ZERO
            RT1I = ZERO
            RT2R = ZERO
            RT2I = ZERO
         ELSE
            H11 = H11 / S
            H21 = H21 / S
            H12 = H12 / S
            H22 = H22 / S
            TR = ( H11+H22 ) / TWO
            DET = ( H11-TR )*( H22-TR ) - H12*H21
            RTDISC = SQRT( ABS( DET ) )
            IF( DET.GE.ZERO ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              ==== complex conjugate shifts ====
</span><span class="comment">*</span><span class="comment">
</span>               RT1R = TR*S
               RT2R = RT1R
               RT1I = RTDISC*S
               RT2I = -RT1I
            ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              ==== real shifts (use only one of them)  ====
</span><span class="comment">*</span><span class="comment">
</span>               RT1R = TR + RTDISC
               RT2R = TR - RTDISC
               IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
                  RT1R = RT1R*S
                  RT2R = RT1R
               ELSE
                  RT2R = RT2R*S
                  RT1R = RT2R
               END IF
               RT1I = ZERO
               RT2I = ZERO
            END IF
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Look for two consecutive small subdiagonal elements.
</span><span class="comment">*</span><span class="comment">
</span>         DO 50 M = I - 2, L, -1
<span class="comment">*</span><span class="comment">           Determine the effect of starting the double-shift QR
</span><span class="comment">*</span><span class="comment">           iteration at row M, and see if this would make H(M,M-1)
</span><span class="comment">*</span><span class="comment">           negligible.  (The following uses scaling to avoid
</span><span class="comment">*</span><span class="comment">           overflows and most underflows.)
</span><span class="comment">*</span><span class="comment">
</span>            H21S = H( M+1, M )
            S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S )
            H21S = H( M+1, M ) / S
            V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )*
     $               ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S )
            V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R )
            V( 3 ) = H21S*H( M+2, M+1 )
            S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) )
            V( 1 ) = V( 1 ) / S
            V( 2 ) = V( 2 ) / S
            V( 3 ) = V( 3 ) / S
            IF( M.EQ.L )
     $         GO TO 60
            IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE.
     $          ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M,
     $          M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60
   50    CONTINUE
   60    CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Double-shift QR step
</span><span class="comment">*</span><span class="comment">
</span>         DO 130 K = M, I - 1
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           The first iteration of this loop determines a reflection G
</span><span class="comment">*</span><span class="comment">           from the vector V and applies it from left and right to H,
</span><span class="comment">*</span><span class="comment">           thus creating a nonzero bulge below the subdiagonal.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Each subsequent iteration determines a reflection G to
</span><span class="comment">*</span><span class="comment">           restore the Hessenberg form in the (K-1)th column, and thus
</span><span class="comment">*</span><span class="comment">           chases the bulge one step toward the bottom of the active
</span><span class="comment">*</span><span class="comment">           submatrix. NR is the order of G.
</span><span class="comment">*</span><span class="comment">
</span>            NR = MIN( 3, I-K+1 )
            IF( K.GT.M )
     $         CALL SCOPY( NR, H( K, K-1 ), 1, V, 1 )
            CALL <a name="SLARFG.369"></a><a href="slarfg.f.html#SLARFG.1">SLARFG</a>( NR, V( 1 ), V( 2 ), 1, T1 )
            IF( K.GT.M ) THEN
               H( K, K-1 ) = V( 1 )
               H( K+1, K-1 ) = ZERO
               IF( K.LT.I-1 )
     $            H( K+2, K-1 ) = ZERO
            ELSE IF( M.GT.L ) THEN
               H( K, K-1 ) = -H( K, K-1 )
            END IF
            V2 = V( 2 )
            T2 = T1*V2
            IF( NR.EQ.3 ) THEN
               V3 = V( 3 )
               T3 = T1*V3
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Apply G from the left to transform the rows of the matrix
</span><span class="comment">*</span><span class="comment">              in columns K to I2.
</span><span class="comment">*</span><span class="comment">
</span>               DO 70 J = K, I2
                  SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
                  H( K, J ) = H( K, J ) - SUM*T1
                  H( K+1, J ) = H( K+1, J ) - SUM*T2
                  H( K+2, J ) = H( K+2, J ) - SUM*T3
   70          CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Apply G from the right to transform the columns of the
</span><span class="comment">*</span><span class="comment">              matrix in rows I1 to min(K+3,I).
</span><span class="comment">*</span><span class="comment">
</span>               DO 80 J = I1, MIN( K+3, I )
                  SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
                  H( J, K ) = H( J, K ) - SUM*T1
                  H( J, K+1 ) = H( J, K+1 ) - SUM*T2
                  H( J, K+2 ) = H( J, K+2 ) - SUM*T3
   80          CONTINUE
<span class="comment">*</span><span class="comment">
</span>               IF( WANTZ ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Accumulate transformations in the matrix Z
</span><span class="comment">*</span><span class="comment">
</span>                  DO 90 J = ILOZ, IHIZ
                     SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
                     Z( J, K ) = Z( J, K ) - SUM*T1
                     Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
                     Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
   90             CONTINUE
               END IF
            ELSE IF( NR.EQ.2 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Apply G from the left to transform the rows of the matrix
</span><span class="comment">*</span><span class="comment">              in columns K to I2.
</span><span class="comment">*</span><span class="comment">
</span>               DO 100 J = K, I2
                  SUM = H( K, J ) + V2*H( K+1, J )
                  H( K, J ) = H( K, J ) - SUM*T1
                  H( K+1, J ) = H( K+1, J ) - SUM*T2
  100          CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Apply G from the right to transform the columns of the
</span><span class="comment">*</span><span class="comment">              matrix in rows I1 to min(K+3,I).
</span><span class="comment">*</span><span class="comment">
</span>               DO 110 J = I1, I
                  SUM = H( J, K ) + V2*H( J, K+1 )
                  H( J, K ) = H( J, K ) - SUM*T1
                  H( J, K+1 ) = H( J, K+1 ) - SUM*T2
  110          CONTINUE
<span class="comment">*</span><span class="comment">
</span>               IF( WANTZ ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Accumulate transformations in the matrix Z
</span><span class="comment">*</span><span class="comment">
</span>                  DO 120 J = ILOZ, IHIZ
                     SUM = Z( J, K ) + V2*Z( J, K+1 )
                     Z( J, K ) = Z( J, K ) - SUM*T1
                     Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
  120             CONTINUE
               END IF
            END IF
  130    CONTINUE
<span class="comment">*</span><span class="comment">
</span>  140 CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Failure to converge in remaining number of iterations
</span><span class="comment">*</span><span class="comment">
</span>      INFO = I
      RETURN
<span class="comment">*</span><span class="comment">
</span>  150 CONTINUE
<span class="comment">*</span><span class="comment">
</span>      IF( L.EQ.I ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        H(I,I-1) is negligible: one eigenvalue has converged.
</span><span class="comment">*</span><span class="comment">
</span>         WR( I ) = H( I, I )
         WI( I ) = ZERO
      ELSE IF( L.EQ.I-1 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Transform the 2-by-2 submatrix to standard Schur form,
</span><span class="comment">*</span><span class="comment">        and compute and store the eigenvalues.
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="SLANV2.470"></a><a href="slanv2.f.html#SLANV2.1">SLANV2</a>( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
     $                H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
     $                CS, SN )
<span class="comment">*</span><span class="comment">
</span>         IF( WANTT ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Apply the transformation to the rest of H.
</span><span class="comment">*</span><span class="comment">
</span>            IF( I2.GT.I )
     $         CALL SROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
     $                    CS, SN )
            CALL SROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
         END IF
         IF( WANTZ ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Apply the transformation to Z.
</span><span class="comment">*</span><span class="comment">
</span>            CALL SROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
         END IF
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     return to start of the main loop with new value of I.
</span><span class="comment">*</span><span class="comment">
</span>      I = L - 1
      GO TO 20
<span class="comment">*</span><span class="comment">
</span>  160 CONTINUE
      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="SLAHQR.499"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>
